SGI Freeware 1999 August/SGI Freeware 1999 August.iso/dist/fw_Tix.idb/usr/freeware/lib/tix4.1/Event.tcl.z/Event.tcl

Text File | 1999-01-26 | 5.4 KB | 236 lines

# Event.tcl --
#
#    Handles the event bindings of the -command and -browsecmd options
#    (and various of others such as -validatecmd).
#
# Copyright (c) 1996, Expert Interface Technologies
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

#----------------------------------------------------------------------
# Evaluate high-level bindings (-command, -browsecmd, etc):
# with % subsitution or without (compatibility mode)
#
#
# BUG : if a -command is intercepted by a hook, the hook must use
#       the same record name as the issuer of the -command. For the time
#    being, you must use the name "bind" as the record name!!!!!
#
#----------------------------------------------------------------------
set _tix_event_flags ""
append _tix_event_flags " %%"
append _tix_event_flags " %#"
#append _tix_event_flags " %a"
append _tix_event_flags " %b"
append _tix_event_flags " %c"
append _tix_event_flags " %d"
append _tix_event_flags " %f"
append _tix_event_flags " %h"
append _tix_event_flags " %k"
append _tix_event_flags " %m"
append _tix_event_flags " %o"
append _tix_event_flags " %p"
append _tix_event_flags " %s"
append _tix_event_flags " %t"
append _tix_event_flags " %w"
append _tix_event_flags " %x"
append _tix_event_flags " %y"
append _tix_event_flags " %A"
append _tix_event_flags " %B"
append _tix_event_flags " %E"
append _tix_event_flags " %K"
append _tix_event_flags " %N"
append _tix_event_flags " %R"
#append _tix_event_flags " %S"
append _tix_event_flags " %T"
append _tix_event_flags " %W"
append _tix_event_flags " %X"
append _tix_event_flags " %Y"

proc tixBind {tag event action} {
    global _tix_event_flags

    append cmd "_tixRecordFlags $event $_tix_event_flags;"
    append cmd "$action; "
    append cmd "_tixDeleteFlags"

    bind $tag $event $cmd
}

# This is a "name stack" for storing the "bind" structures
#
# The bottom of the event stack is usually a raw event (generated by tixBind)
# but it may also be a programatically triggered (caused by tixEvalCmdBinding)
#
#

set tixEvent(nameStack)        ""
set tixEvent(stackLevel)        0

proc tixPushEventStack {} {
    global tixEvent

    set lastEvent [lindex $tixEvent(nameStack) 0]
    incr tixEvent(stackLevel)
    set thisEvent _tix_event$tixEvent(stackLevel)

    set tixEvent(nameStack) \
    [list $thisEvent $tixEvent(nameStack)]

    if {$lastEvent == ""} {
    upvar #0 $thisEvent this
    set this(type) <Application>
    } else {
    upvar #0 $lastEvent last
    upvar #0 $thisEvent this

    foreach name [array names last] {
        set this($name) $last($name)
    }
    }

    return $thisEvent
}

proc tixPopEventStack {varName} {
    global tixEvent

    if {$varName != [lindex $tixEvent(nameStack) 0]} {
    error "unmatched tixPushEventStack and tixPopEventStack calls"
    }
    incr tixEvent(stackLevel) -1
    set tixEvent(nameStack) [lindex $tixEvent(nameStack) 1]
    global $varName
    unset $varName
}


# Events triggered by tixBind
#
proc _tixRecordFlags [concat event $_tix_event_flags] {
    global _tix_event_flags

    set thisName [tixPushEventStack]; upvar #0 $thisName this

    set this(type) $event
    foreach f $_tix_event_flags {
    set this($f) [set $f]
    }
}

proc _tixDeleteFlags {} {
    global tixEvent

    tixPopEventStack [lindex $tixEvent(nameStack) 0]
}

# programatically trigged events
#
proc tixEvalCmdBinding {w cmd {subst ""} args} {
    global tixPriv tixEvent tix

    set thisName [tixPushEventStack]; upvar #0 $thisName this

    if {$subst != ""} {
    upvar $subst bind

    if [info exists bind(specs)] {
        foreach spec $bind(specs) {
        set this($spec) $bind($spec)
        }
    }
    if [info exists bind(type)] {
        set this(type) $bind(type)
    }
    }

    if [catch {
    if [tixGetBoolean -nocomplain $tix(-extracmdargs)] {
        # Compatibility mode
        #
        set ret [uplevel #0 $cmd $args]
    } else {
        set ret [uplevel $cmd]
    }
    } error] {
    if [catch {
        tixCmdErrorHandler $error
    } error] {
        # double fault: just print out
        tixBuiltInCmdErrorHandler $error
    }
    tixPopEventStack $thisName
    return ""
    } else {
    tixPopEventStack $thisName

    return $ret
    }
}

proc tixEvent {option args} {
    global tixPriv  tixEvent
    set varName [lindex $tixEvent(nameStack) 0]

    if {$varName == ""} {
    error "tixEvent called when no event is being processed"
    } else {
    upvar #0 $varName event
    }

    case $option {
    type {
        return $event(type)
    }
    value {
        if [info exists event(%V)] {
        return $event(%V)
        } else {
        return ""
        }
    }
    flag {
        set f %[lindex $args 0]
        if [info exists event($f)] {
        return $event($f)
        }
        error "The flag \"[lindex $args 0]\" does not exist"
    }
    match {
        return [string match [lindex $args 0] $event(type)]
    }
    default {
        error "unknown option \"$option\""
    }
    }
}

# tixBuiltInCmdErrorHandler --
#
#    Default method to report command handler errors. This procedure is
#    also called if double-fault happens (command handler causes error,
#    then tixCmdErrorHandler causes error).
#
proc tixBuiltInCmdErrorHandler {errorMsg} {
    global errorInfo
    if ![info exists errorInfo] {
    set errorInfo "???"
    }
    puts "Error:\n $errorMsg\n$errorInfo"
}

# tixCmdErrorHandler --
#
#    You can redefine this command to handle the errors that occur
#    in the command handlers. See the programmer's documentation
#    for details
#
if ![string compare [info command tixCmdErrorHandler] ""] {
    proc tixCmdErrorHandler {errorMsg} {
    tixBuiltInCmdErrorHandler $errorMsg
    }
}